Software 2000/Software 2000 Volume 1 (Disc 1 of 2).iso/utilities/u287.dms/in.adf/Source/Expr.p

Text File | 1991-04-19 | 27.0 KB | 1,005 lines

External;

{$I "Pascal.i"}

    Function TypeCheck(l, r : TypePtr) : Boolean;
        External;
    Function TypeCmp(l, r : TypePtr) : Boolean;
        External;
    Procedure ReadChar;
        External;
    Procedure NextSymbol;
        External;
    Procedure Error(s : string);
        External;
    Procedure Abort;
        External;
    Function Match(s : Symbols): Boolean;
        External;
    Function FindID(s : string) : IDPtr;
        External;
    Function FindField(s : string; TP : TypePtr): IDPtr;
        External;
    Function FindWithField(S : String) : IDPtr;
        External;
    Procedure Mismatch;
        External;
    Procedure NeedRightParent;
        External;
    Procedure NeedLeftParent;
        External;
    Procedure NeedNumber;
        External;
    Function NumberType(l : TypePtr) : Boolean;
        External;
    Function BaseType(b : TypePtr): TypePtr;
        External;
    Function SimpleType(t : TypePtr) : Boolean;
        External;
    Function EnterStandard(    st_Name : String;
                st_Object : IDObject;
                st_Type : TypePtr;
                st_Storage : IDStorage;
                st_Offset : Integer) : IDPtr;
        External;

Function GetExpressionNode : ExprPtr;
var
    Expr : ExprPtr;
begin
    if NextFreeExprNode <= MaxExprNodes then begin
    Expr := Adr(ExpressionNodeStore[NextFreeExprNode]);
    Inc(NextFreeExprNode);
    GetExpressionNode := Expr;
    end else begin
    New(Expr);
    GetExpressionNode := Expr;
    end;
end;

Procedure FreeExpressionNode(Expr : ExprPtr);
begin
    Expr^.Used := False;
end;

Function MakeNode(Op : Symbols; L, R : ExprPtr; TP : TypePtr; Val : Integer) : ExprPtr;
var
    Expr : ExprPtr;
begin
    Expr := GetExpressionNode;
    with Expr^ do begin
    Kind    := Op;
    Next    := Nil;
    Left    := L;
    Right    := R;
    EType    := BaseType(TP);
    Value    := Val;
    end;
    MakeNode := Expr;
end;

Function MakeBinary(Op : Symbols; L, R : ExprPtr; TP : TypePtr) : ExprPtr;
begin
    MakeBinary := MakeNode(Op,L,R,TP,0);
end;

Function MakeCommutativeBinary(Op : Symbols; L, R : ExprPtr; TP : TypePtr) : ExprPtr;
begin
    if L^.Kind = Const1 then
    MakeCommutativeBinary := MakeNode(Op, L, R, TP, 0);
    if R^.Kind = Const1 then
        MakeCommutativeBinary := MakeNode(Op, R, L, TP, 0);
    if (L^.Kind = Var1) or (L^.Kind = Period1) then
    MakeCommutativeBinary := MakeNode(Op, L, R, TP, 0);
    MakeCommutativeBinary := MakeNode(Op, R, L, TP, 0);
end;

Function MakeConstant(Val : Integer; TP : TypePtr) : ExprPtr;
begin
    if (TP = StringType) or (TP^.Object = ob_array) then
    MakeConstant := MakeNode(Quote1, Nil, Nil, TP, Val)
    else
    MakeConstant := MakeNode(Const1, Nil, Nil, TP, Val);
end;

Function MakeVariable(ID : IDPtr; TP : TypePtr) : ExprPtr;
begin
    MakeVariable := MakeNode(Var1, Nil, Nil, TP, Integer(ID));
end;

Function CommonType(type1, type2 : TypePtr) : TypePtr;
begin
    Type1 := BaseType(Type1);
    Type2 := BaseType(Type2);
    if (Type1 = BadType) or (Type2 = BadType) then
        CommonType := BadType;
    if (Type1 = RealType) or (Type2 = RealType) then
        CommonType := RealType;
    if (Type1 = IntType) or (Type2 = IntType) then
        CommonType := IntType;
    if (Type1 = ShortType) or (Type2 = ShortType) then
    CommonType := ShortType;
    if (Type1 = ByteType) or (Type2 = ByteType) then
    CommonType := ByteType;
    CommonType := Type1; { What else is there? }
end;

Function PromoteTypeA(Expr : ExprPtr; TP : TypePtr) : ExprPtr;
var
    Common : TypePtr;
begin
    Common := CommonType(Expr^.EType, TP);
    if (Common = Expr^.EType) or (Common = BadType) then
        PromoteTypeA := Expr;

    if Common = RealType then
    PromoteTypeA := MakeBinary(int2real, PromoteTypeA(Expr, IntType),
                Nil, RealType)
    else if Common = IntType then
    PromoteTypeA := MakeBinary(short2long, PromoteTypeA(Expr, ShortType),
                    Nil, IntType)
    else if Common = ShortType then
    PromoteTypeA := MakeBinary(byte2short, Expr, Nil, ShortType)
    else
    PromoteTypeA := Expr;
end;

Procedure CheckNumeric(Expr : ExprPtr);
begin
    if not NumberType(Expr^.EType) then begin
    NeedNumber;
        Expr^.EType := BadType;
    end;
end;

Procedure CheckType(Left, Right : ExprPtr);
begin
    if not TypeCheck(Left^.EType, Right^.EType) then begin
    MisMatch;
    Left^.EType := BadType;
    Right^.EType := BadType;
    end;
end;

Procedure CheckOrdinal(Expr : ExprPtr);
begin
    if Expr^.EType^.Object <> ob_ordinal then begin
    Expr^.EType := BadType;
    Error("Expecting an Ordinal Expression");
    end;
end;

Function AutoInt(Expr : ExprPtr) : ExprPtr;
begin
    with Expr^ do begin
    if EType = RealType then
        AutoInt := MakeNode(real2int,Expr,Nil,IntType,0)
    else
        AutoInt := Expr;
    end;
end;

Function ExpressionTree : ExprPtr;
    Forward;
Function Factor : ExprPtr;
    Forward;
Function GetReference : ExprPtr;
    Forward;

Function BuildError(ErrorMsg : String) : ExprPtr;
begin
    Error(ErrorMsg);
    BuildError := MakeNode(unknown1, Nil, Nil, BadType, 0);
end;

Function OrdinalError : ExprPtr;
begin
    OrdinalError := BuildError("Expecting an ordinal expression");
end;

Function NumericError : ExprPtr;
begin
    NumericError := BuildError("Expecting a numeric expression");
end;

Procedure IncLitPtrA;
begin
    if LitPtr >= LiteralSize then begin
    Writeln('Too much literal data');
    Abort;
    end else
    Inc(LitPtr);
end;

Function ReadLitA(Quote : Char) : TypePtr;

{
    This routine reads a literal array of char into the literal
array.
}
var
    Length : Short;
begin
    Length := 1;
    while (currentchar <> Quote) and (currentchar <> chr(10)) do begin
    if CurrentChar = '\\' then begin
        ReadChar;
        if CurrentChar = Chr(10) then
        Error("Missing closing quote");
        case CurrentChar of
          'n' : Litq[LitPtr] := Chr(10);
          't' : Litq[LitPtr] := Chr(9);
          '0' : Litq[LitPtr] := Chr(0);
          'b' : Litq[LitPtr] := Chr(8);
          'e' : Litq[LitPtr] := Chr(27);
          'c' : Litq[LitPtr] := Chr($9B);
          'a' : Litq[LitPtr] := Chr(7);
          'f' : Litq[LitPtr] := Chr(12);
          'r' : Litq[LitPtr] := Chr(13);
          'v' : Litq[LitPtr] := Chr(11);
        else
        Litq[LitPtr] := CurrentChar;
        end;
    end else
        Litq[LitPtr] := CurrentChar;
    if CurrentChar <> Chr(10) then begin
        ReadChar;
        if currentchar = chr(10) then
        error("Missing closing quote");
    end;
    Inc(Length);
    IncLitPtrA;
    end;
    ReadChar;
    NextSymbol;
    if Quote = '"' then begin
    LitQ[LitPtr] := Chr(0);
    IncLitPtrA;
    ReadLitA := StringType;
    end else begin
    LiteralType^.Upper := Length - 1;
    ReadLitA := LiteralType;
    end;
end;

Function GetStandardFunction(ID : IDPtr) : ExprPtr;
var
    Expr : ExprPtr;
    Expr2 : ExprPtr;
    TypeID : IDPtr;
begin
    NeedLeftParent;
    if (ID^.Offset < 15) or (ID^.Offset > 16) then
    Expr := ExpressionTree;

    case ID^.Offset of
{Ord} 1 : begin
        if Expr^.EType^.Object = ob_ordinal then begin
        case Expr^.EType^.Size of
          1 : Expr := MakeNode(stanfunc1, Expr, Nil, ByteType, 1);
          2 : Expr := MakeNode(stanfunc1, Expr, Nil, ShortType, 1);
          4 : Expr := MakeNode(stanfunc1, Expr, Nil, IntType, 1);
        end;
        end else
        Expr := OrdinalError;
      end;
{Chr} 2 : if NumberType(Expr^.EType) then
          Expr := MakeNode(stanfunc1, AutoInt(Expr), Nil, CharType, 2)
      else
          Expr := NumericError;
{Odd} 3 : if NumberType(Expr^.EType) then
          Expr := MakeNode(stanfunc1, AutoInt(Expr), Nil, BoolType, 3)
      else
          Expr := NumericError;
{Abs}  4 : if NumberType(Expr^.EType) then
          Expr := MakeNode(stanfunc1, Expr, Nil, Expr^.EType, ID^.Offset)
      else
          Expr := NumericError;
{Succ} 5,
{Pred} 6 : if Expr^.Etype^.Object = ob_ordinal then
           Expr := MakeNode(stanfunc1, Expr, Nil, Expr^.EType, ID^.Offset)
       else
           Expr := OrdinalError;
{ReOpen} 7,
{Open}   8 :
        begin
        if TypeCheck(StringType,Expr^.EType) then begin
            if not Match(comma1) then
            Error("Expecting a comma");
            Expr2 := GetReference;
            if Expr2^.EType^.Object = ob_file then
            Expr := MakeNode(stanfunc1, Expr2, Expr, BoolType, ID^.Offset)
            else
            Expr := BuildError("Expecting a file type");
            if Match(Comma1) then begin
            Expr2 := ExpressionTree;
            if not TypeCheck(Expr2^.EType,IntType) then
                Expr2 := BuildError("Mismatched Types");
            end else
            Expr2 := MakeNode(Const1,Nil,Nil,IntType,128);
            Expr^.Left^.Next := Expr2;
        end else
            Expr := BuildError("Expecting a string expression");
        end;
{EOF} 9 : if Expr^.EType^.Object = ob_file then
          Expr := MakeNode(stanfunc1, Expr, Nil, BoolType, 9)
      else
          Expr := BuildError("Expecting a file variable");
{Trunc} 10,
{Round} 11 :
        if TypeCmp(Expr^.EType,RealType) then
        Expr := MakeNode(stanfunc1, Expr, Nil, IntType, ID^.Offset)
        else
        Expr := BuildError("Expecting a floating point expression");
{Float} 12 : if NumberType(Expr^.EType) and (Expr^.EType^.Object = ob_ordinal) then
        Expr := MakeNode(stanfunc1, PromoteTypeA(Expr,IntType),
                    Nil, RealType, 12)
         else
        Expr := BuildError("Expecting an ordinal number");
{Floor} 13,
{Ceil}  14 : if TypeCmp(Expr^.EType, RealType) then
        Expr := MakeNode(stanfunc1, Expr, Nil, RealType, ID^.Offset)
         else
        Expr := BuildError("Expecting a floating point expression");
{SizeOf}
     15 : begin
         if CurrSym = Ident1 then begin
        TypeID := FindId(SymText);
        if TypeID <> Nil then begin
            if TypeID^.Object = obtype then
            Expr := MakeNode(Const1, Nil, Nil, IntType, TypeID^.VType^.Size)
            else
            Expr := BuildError("Expecting a type");
        end else
            Expr := BuildError("Unknown ID");
        end else
        Expr := BuildError("Expecting an ID");
        NextSymbol;
    end;
{Adr}
     16 : Expr := MakeNode(at1, GetReference, Nil, AddressType, 0);
{Bit}
     17 : if NumberType(Expr^.EType) and (Expr^.EType^.Object = ob_ordinal) then
          Expr := MakeNode(shl1, MakeConstant(1,IntType), Expr, IntType, 17)
      else
          Expr := BuildError("Expecting an ordinal number");
{Sqr}18 : if NumberType(Expr^.EType) then
          Expr := MakeNode(stanfunc1, Expr, Nil, Expr^.EType, 18)
      else
          Expr := NumericError;
     19..25 : { Sin, Cos, Sqrt, Tan, ArcTan, Ln, Exp }
        if NumberType(Expr^.EType) then
        Expr := MakeNode(stanfunc1, PromoteTypeA(Expr,RealType),
                        Nil, RealType, ID^.Offset)
        else
        Expr := NumericError;
    end;
    NeedRightParent;
    GetStandardFunction := Expr;
end;

Function ReadParameters(ID : IDPtr) : ExprPtr;
var
    CurrentParam    : IDPtr;
    stay        : Boolean;
    argtype        : TypePtr;
    argindex        : integer;
    totalsize        : integer;
    lab            : integer;
    Expr        : ExprPtr;
    Argument        : ExprPtr;
    NextExpr        : ExprPtr;
begin
    Stay := True;
    Expr := MakeNode(func1, Nil, Nil, ID^.VType, Integer(ID));
    NextExpr := Nil;
    if Match(LeftParent1) then begin
    CurrentParam := ID^.Param;
    while (not Match(RightParent1)) and Stay do begin
        if CurrentParam = Nil then
        ReadParameters := BuildError("Argument not expected");
        if CurrentParam^.Object = valarg then begin
        Argument := ExpressionTree;
        if not TypeCheck(Argument^.EType, CurrentParam^.VType) then begin
            Mismatch;
            Argument := MakeConstant(1,BadType);
        end else begin
            if NumberType(Argument^.EType) then begin
            if (Argument^.EType = RealType) and
               (CurrentParam^.VType^.Object = ob_ordinal) then
                Argument := MakeNode(Real2Int,
                        PromoteTypeA(Argument, IntType),
                        Nil,
                        CurrentParam^.VType,0)
            else
                Argument := PromoteTypeA(Argument, CurrentParam^.VType);
            end;
        end;
        end else if CurrentParam^.Object = refarg then begin
        Argument := GetReference;
        if not TypeCmp(Argument^.EType, CurrentParam^.VType) then
            Mismatch;
        end;
        if NextExpr = Nil then
        Expr^.Left := Argument
        else
        NextExpr^.Next := Argument;
        NextExpr := Argument;
        CurrentParam := CurrentParam^.Next;
        if CurrentParam <> Nil then
        if not Match(Comma1) then
            Error("Expected ,");
    end;
    if CurrentParam <> Nil then
        error("More Parameters Expected");
    end else begin
    if ID^.Param <> Nil then
        error("Expecting Some Parameters");
    end;
    ReadParameters := Expr;
end;

{
   This function reads an identifier and makes an appropriate
   node.  The identifier can be a variable, function, constant,
   or standard function.
}

Function ReadIdentifier : ExprPtr;
var
    Expr : ExprPtr;
    NextExpr : ExprPtr;
    ID    : IDPtr;
begin
    ID := FindWithField(SymText);
    if ID = Nil then
    ID := FindID(SymText);
    NextSymbol;
    if ID = Nil then begin
    ID := EnterStandard(SymText, global, BadType, st_none, 1);
    { ReadBadArgs(ID); }
    ReadIdentifier := BuildError("Unknown ID");
    end;
    case ID^.Object of
      obtype : begin
           NeedLeftParent;
           Expr := MakeBinary(Type1, ExpressionTree, Nil, ID^.VType);
           NeedRightParent;
           end;
      constant : Expr := MakeConstant(ID^.Offset, ID^.VType);
      global,
      local,
      refarg,
      valarg   : Expr := MakeNode(Var1, Nil, Nil, ID^.VType, Integer(ID));
      typed_const : if ConstantExpression then
            Expr := MakeConstant(ID^.Offset, ID^.VType)
            else
            Expr := MakeNode(Var1, Nil, Nil, ID^.VType, Integer(ID));
      func     : Expr := ReadParameters(ID);
      stanfunc : Expr := GetStandardFunction(ID);
      field    : Expr := MakeNode(Field1,ExprPtr(LastWith),Nil,ID^.VType,Integer(ID));
    else
    Expr := BuildError("Expecting a variable or function reference");
    end;
    ReadIdentifier := Expr;
end;

Function Primary : ExprPtr;
var
    Expr    : ExprPtr;
    TP,TP2  : TypePtr;
    LitSpot : Integer;
begin
    case CurrSym of
      numeral1 : begin
            if Abs(SymLoc) > 32767 then
            Expr := MakeConstant(SymLoc, IntType)
            else if (SymLoc > 255) or (SymLoc < 0) then
            Expr := MakeConstant(SymLoc, ShortType)
            else
            Expr := MakeConstant(SymLoc, ByteType);
                    NextSymbol;
                end;
      realnumeral1:
        begin
            Expr := MakeConstant(Integer(RealValue), RealType);
                    NextSymbol;
                end;
      minus1  : begin
            NextSymbol;
            Expr := Factor;
            if not NumberType(Expr^.EType) then
            Expr := BuildError("Expecting a numeric type")
            else
            Expr := MakeNode(minus1, Expr, Nil, Expr^.EType, 0);
        end;
      plus1   : begin
            NextSymbol;
            Expr := Factor;
            if not NumberType(Expr^.EType) then
            Expr := BuildError("Expecting a numeric type");
        end;
      at1 :     begin
            NextSymbol;
            Expr := MakeNode(at1, GetReference, Nil, AddressType, 0);
        end;
      not1    : begin
            NextSymbol;
            Expr := Factor;
            if Expr^.EType^.Object <> ob_ordinal then
            Expr := BuildError("Expecting an ordinal type")
            else
            Expr := MakeNode(not1, Expr, Nil, Expr^.EType, 0);
        end;
      ident1  : Expr := ReadIdentifier;
      leftparent1 :
        begin
            NextSymbol;
            Expr := ExpressionTree;
            NeedRightParent;
        end;
      Apostrophe1 :
        begin
            LitSpot := LitPtr;
            TP := ReadLitA(Chr(39));
            if TP^.Upper = 1 then begin
            Dec(LitPtr);
            Expr := MakeConstant(Ord(LitQ[LitPtr]), CharType);
            end else begin
            New(TP2);  { Add new type for array }
            TP2^ := TP^;
            TP2^.Next := CurrentBlock^.FirstType;
            CurrentBlock^.FirstType := TP2;
            Expr := MakeNode(quote1, Nil, Nil, TP2, LitSpot);
            end;
        end;
      Quote1 :  begin
            LitSpot := LitPtr;
            TP := ReadLitA('"');
            Expr := MakeNode(quote1, Nil, Nil, TP, LitSpot);
        end;
    else
        Expr := BuildError("Unknown Factor");
    end;
    Primary := Expr;
end;

Function MakeFieldRef(Expr : ExprPtr; Offset : Integer; TP : TypePtr) : ExprPtr;
begin
    if Expr^.Kind = period1 then begin
        Expr^.Value := Expr^.Value + Offset;
        Expr^.EType := TP;
        MakeFieldRef := Expr;
    end;
    MakeFieldRef := MakeNode(Period1, Expr, Nil, TP, Offset);
end;

Function MakeIndirection(Expr : ExprPtr) : ExprPtr;
var
    Result : ExprPtr;
begin
    MakeIndirection := MakeNode(Carat1, Expr, Nil, Expr^.EType^.SubType, 0);
end;

Function MakeIndex(L, R : ExprPtr; TP : TypePtr) : ExprPtr;
var
    Result : ExprPtr;
begin

{
    These first statements create the following structure:

        *
           / \
     element  -
      size   /  \
          promote\
           /      lower bound
         index
       expression

    Which is the general calculation for array addressing:
    base address + (index - lower bound) * element size

    L := The expression for the array address
    R := The expression for the index
}

    case R^.EType^.Size of
      1 : R^.EType := ByteType;
      2 : R^.EType := ShortType;
      4 : R^.EType := IntType;
    end;

    with L^.EType^ do begin
    if Lower <> 0 then
        R := MakeBinary(minus1,MakeConstant(Lower,R^.EType),
                R, R^.EType);
    if (Upper > MaxShort) or (SubType^.Size > MaxShort) then begin
        R := MakeBinary(asterisk1,
            MakeConstant(SubType^.Size,IntType),
            PromoteTypeA(R,IntType),
            IntType)
    end else begin
        R := MakeBinary(asterisk1,
            MakeConstant(SubType^.Size,ShortType),
            PromoteTypeA(R,ShortType),IntType);
    end;
    end;
    MakeIndex := MakeNode(LeftBrack1, L, R, TP, 0);
end;

Function GetReference : ExprPtr;
var
    Left,
    Right  : ExprPtr;
    Leave  : Boolean;
    TP     : TypePtr;
    ID     : IDPtr;
begin
    ID := FindWithField(SymText);
    if ID = Nil then
    ID := FindID(SymText);
    NextSymbol;

    if ID = Nil then begin
    ID := EnterStandard(SymText, global, BadType, st_none, 1);
    { ReadBadArgs(ID); }
    GetReference := BuildError("Unknown ID");
    end;

    case ID^.Object of
      obtype : begin
           NeedLeftParent;
           Left := MakeNode(type1, GetReference, Nil, ID^.VType, 0);
           NeedRightParent;
           end;
      global,
      local,
      refarg,
      typed_const,
      valarg,
      proc,
      func    : Left := MakeNode(Var1, Nil, Nil, ID^.VType, Integer(ID));
      field    : Left := MakeNode(Field1, ExprPtr(LastWith), Nil, ID^.VType, Integer(ID));
    else
    GetReference := BuildError("Expecting an identifier");
    end;

    Leave := False;
    repeat
        case CurrSym of { handle ., [, and '^' here }
          period1 : begin
            NextSymbol;
            if Left^.EType^.Object = ob_record then begin
                if CurrSym = ident1 then begin
                ID := FindField(SymText, Left^.EType);
                if ID <> Nil then
                    Left := MakeFieldRef(Left, ID^.Offset, ID^.VType)
                else
                    Left := BuildError("Unknown Field");
                NextSymbol;
                end else
                Left := BuildError("Expecting an identifier");
            end else
                Left := BuildError("Not a Record Type");
                    end;
          carat1 :  begin
            NextSymbol;
            if (Left^.EType^.Object <> ob_pointer) and
               (Left^.EType^.Object <> ob_file) then
                Left := BuildError("Expecting a pointer or file for ^")
            else
                Left := MakeIndirection(Left)
            end;
          leftbrack1 :
            begin
            NextSymbol;
            repeat
                if Left^.EType^.Object = ob_array then begin
                Right := ExpressionTree;
                if not TypeCheck(Right^.EType, Left^.EType^.Ref) then
                    MisMatch;
                if Right^.Kind = Const1 then begin
                    if RangeCheck then begin
                    if (Right^.Value > Left^.EType^.Upper) or
                       (Right^.Value < Left^.EType^.Lower) then
                        Error("Index out of range");
                    end;
                    Left := MakeFieldRef(Left,
                       (Right^.Value - Left^.EType^.Lower) *
                        Left^.EType^.SubType^.Size,
                        Left^.EType^.SubType)
                end else
                    Left := MakeIndex(Left,Right,Left^.EType^.SubType);
                end else if Left^.EType = StringType then begin
                Right := ExpressionTree;
                if TypeCheck(Right^.EType, IntType) then
                    Left := MakeIndex(Left,Right,CharType)
                else
                    Left := BuildError("Expecting an integer index");
                end else
                Left := BuildError("Not an Array Type");
            until not Match(Comma1);
            if not Match(RightBrack1) then
                Error("Expecting ]");
            end;
        else
            Leave := True;
        end;
    until Leave;
    GetReference := Left;
end;

{ Create a factor tree.  This level handles the seperators, which in
  version 1.2 are now considered operators. }

Function Factor : ExprPtr;
var
    Left,
    Right  : ExprPtr;
    Leave  : Boolean;
    TP     : TypePtr;
    ID     : IDPtr;
begin
    Left := Primary;
    Leave := False;
    repeat
        case CurrSym of { handle ., [, and '^' here }
          period1 : begin
            NextSymbol;
            if Left^.EType^.Object = ob_record then begin
                if CurrSym = ident1 then begin
                ID := FindField(SymText, Left^.EType);
                if ID <> Nil then
                    Left := MakeFieldRef(Left, ID^.Offset, ID^.VType)
                else
                    Left := BuildError("Unknown Field");
                NextSymbol;
                end else
                Left := BuildError("Expecting an identifier");
            end else
                Left := BuildError("Not a Record Type");
                    end;
          carat1 :  begin
            NextSymbol;
            if (Left^.EType^.Object <> ob_pointer) and
               (Left^.EType^.Object <> ob_file) then
                Left := BuildError("Expecting a pointer or file type")
            else
                Left := MakeIndirection(Left)
            end;
          leftbrack1 :
            begin
            NextSymbol;
            repeat
                if Left^.EType^.Object = ob_array then begin
                Right := ExpressionTree;
                if not TypeCheck(Right^.EType, Left^.EType^.Ref) then
                    MisMatch;
                if Right^.Kind = Const1 then
                    Left := MakeFieldRef(Left,
                        (Right^.Value - Left^.EType^.Lower) *
                         Left^.EType^.SubType^.Size,
                         Left^.EType^.SubType)
                else
                    Left := MakeIndex(Left,Right,Left^.EType^.SubType);
                end else if Left^.EType = StringType then begin
                Right := ExpressionTree;
                if TypeCheck(Right^.EType, IntType) then
                    Left := MakeIndex(Left,Right,CharType)
                else
                    Left := BuildError("Expecting an integer index");
                end else
                Left := BuildError("Not an Array Type");
            until not Match(Comma1);
            if not Match(RightBrack1) then
                Error("Expecting ]");
                    end;
        else
            Leave := True;
        end;
    until Leave;
    Factor := Left;
end;

{ Create a term tree.  This routine handles multiplication, division,
  and, shl, shr, and mod }

Function Term : ExprPtr;
var
    Left,
    Right    : ExprPtr;
    Leave    : Boolean;
    Op       : Symbols;
begin
    Left := Factor;
    Leave := False;
    repeat
        case CurrSym of
          asterisk1:
        begin
            CheckNumeric(Left);
            NextSymbol;
            Right := Factor;
            CheckNumeric(Right);
            CheckType(Left,Right);
            Left  := PromoteTypeA(Left, ShortType); { at least }
            Left  := PromoteTypeA(Left, Right^.EType);
            Right := PromoteTypeA(Right, Left^.EType);
            if Left^.EType^.Size < 4 then
            Left  := MakeCommutativeBinary(asterisk1, Left, Right, IntType)
            else
            Left := MakeBinary(asterisk1, Left, Right, Left^.EType);
        end;
          realdiv1 :
        begin
            CheckNumeric(Left);
            NextSymbol;
            Right := Factor;
            CheckNumeric(Right);
            CheckType(Left,Right);
            Left  := PromoteTypeA(Left, RealType);
            Right := PromoteTypeA(Right, Left^.EType);
            Left := MakeBinary(realdiv1, Right, Left, RealType);
        end;
      div1,
      mod1: begin
            Op := CurrSym;
            CheckNumeric(Left);
            NextSymbol;
            Right := Factor;
            CheckNumeric(Right);
            CheckType(Left,Right);
            Left := AutoInt(Left);
            Right := AutoInt(Right);
            Left  := PromoteTypeA(Left, IntType);
            Right := PromoteTypeA(Right, ShortType);
            Left := MakeBinary(Op, Right, Left, Right^.EType);
        end;
      and1,
      shl1,
      shr1: begin
            Op := CurrSym;
            if Left^.EType = RealType then
            Left := AutoInt(Left)
            else
            CheckOrdinal(Left);
            NextSymbol;
            Right := Factor;
            if Right^.EType = RealType then
            Right := AutoInt(Right)
            else
            CheckOrdinal(Right);
            CheckType(Left,Right);
            if NumberType(Left^.EType) then begin
            Left  := PromoteTypeA(Left, Right^.EType);
            Right := PromoteTypeA(Right, Left^.EType);
            if Op <> and1 then
                Left := PromoteTypeA(Left, IntType);
            end;
            if (Op = And1) and
               ((Left^.EType <> BoolType) or (not ShortCircuit)) then
            Left := MakeCommutativeBinary(Op, Left, Right, Left^.EType)
            else
            Left := MakeBinary(Op, Left, Right, Left^.EType);
        end;
        else
            Leave := True;
        end;
    until Leave;
    Term := Left;
end;

{ Create simple expression tree.  This routine handles +, -, or, and xor }

Function Simple : ExprPtr;
var
    Left,
    Right   : ExprPtr;
    Leave   : Boolean;
    Op      : Symbols;
begin
    Left := Term;
    Leave := False;
    repeat
        case CurrSym of
          plus1,
          minus1 : begin
                      Op := CurrSym;
                      CheckNumeric(Left);
                      NextSymbol;
                      Right := Term;
                      CheckNumeric(Right);
                      CheckType(Left,Right);
                      Left  := PromoteTypeA(Left, Right^.EType);
                      Right := PromoteTypeA(Right, Left^.EType);
                      if Op = plus1 then
                          Left := MakeCommutativeBinary(Op, Left, Right, Left^.EType)
                      else
                          Left := MakeBinary(Op, Right, Left, Left^.EType);
                  end;
      or1,
      xor1: begin
            Op := CurrSym;
            if Left^.EType = RealType then
            Left := AutoInt(Left)
            else
            CheckOrdinal(Left);
            NextSymbol;
            Right := Term;
            if Right^.EType = RealType then
            Right := AutoInt(Right)
            else
            CheckOrdinal(Right);
            CheckType(Left,Right);
            if NumberType(Left^.EType) then begin
            Left  := PromoteTypeA(Left, Right^.EType);
            Right := PromoteTypeA(Right, Left^.EType);
            end;
            if (not ShortCircuit) or (Op <> or1) or
                (Left^.EType <> BoolType) then
            Left := MakeCommutativeBinary(Op, Left, Right, Left^.EType)
            else
            Left := MakeBinary(Op, Left, Right, Left^.EType);
        end;
        else
            Leave := True;
        end;
    until Leave;
    Simple := Left;
end;

{ Create an expression tree.  This routine calls the others, and
  handles comparison operators, which have the lowest precedence. }

Function ExpressionTree : ExprPtr;
var
    Left,
    Right  : ExprPtr;
    Leave  : Boolean;
    Op     : Symbols;
begin
    Left  := Simple;
    Leave := False;
    repeat
        case CurrSym of
          less1,
          greater1,
          notless1,
          notgreater1 : begin
                            Op := CurrSym;
                if Left^.EType <> RealType then
                CheckOrdinal(Left);
                            NextSymbol;
                            Right := Simple;
                if Right^.EType <> RealType then
                CheckOrdinal(Right);
                            CheckType(Left, Right);
                if NumberType(Left^.EType) then begin
                if Left^.EType = ByteType then
                    Left := PromoteTypeA(Left, ShortType);
                Left  := PromoteTypeA(Left, Right^.EType);
                Right := PromoteTypeA(Right, Left^.EType);
                end;
                            Left := MakeBinary(Op, Left, Right, BoolType);
                        end;
          equal1,
          notequal1   : begin
                            Op := CurrSym;
                            NextSymbol;
                            Right := Simple;
                            CheckType(Left, Right);
                if NumberType(Left^.EType) then begin
                Left := PromoteTypeA(Left, Right^.EType);
                Right := PromoteTypeA(Right, Left^.EType);
                end;
                            Left := MakeCommutativeBinary(Op, Left, Right, BoolType);
                        end;
        else
            Leave := True;
        end;
    until Leave;
    ExpressionTree := Left;
end;